home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / DUMP.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  7KB  |  234 lines
  1. Program DUMPProg;
  2.  
  3. {$M 20000,0,50000}
  4.  
  5. uses PbMISC, PbDATA, PbOBJS, PbOUT0, PbPARMS;
  6.  
  7. {
  8. Description:  Simple Hex/ASCII File Dump
  9.  
  10. Author      : Howard Richoux
  11. Date        : 10/10/90
  12. Last revised: 11/18/93  new PbPARMS initializations
  13.               12/25/93  hnr change to PbOUT
  14.                1/16/94  hnr 2.00 BFILE_object
  15.                2/18/94  hnr 2.02 new libraries
  16.                2/22/94  hnr 2.04 moved header buffer to HEAP
  17.                4/30/94  hnr 2.05 error -5 on last partial buffer
  18. Application : IBM PC and compatibles, done in Turbo Pascal 7.0
  19. Status      : Placed in the Public Domain by HNR Software 1/29/94
  20. Published in: none
  21.  
  22. Idiosyncrasy, logic checking on pFirst gets it set to 1.  Record numbering
  23. starts with 0 on files with no header, so to get all records, pFirst checking
  24. is ignored for records 0 and 1.  Otherwise, it should be consistant.
  25.  
  26. }
  27.  
  28.  
  29.  
  30. var  X : BFILE_object;
  31.  
  32. var   recsread     : longint;
  33. var   addr         : longint;
  34. var   HexAddrFlag  : boolean;  {true = HEX false=DEC - mode for addr display }
  35.  
  36. var   RecSize      : integer;
  37. var   HdrSize      : integer;
  38. var   reclineflag  : boolean;
  39. var   hdrlineflag  : boolean;
  40. var   DBFFlag      : boolean;
  41.  
  42.  
  43. Function ThisIsDBFFile(fn: string;var hsiz,rsiz : integer) : boolean;
  44. var f   : BFILE_object;
  45.     buf : array[1..4095] of byte;
  46.     hs,rs : integer;
  47.      begin
  48.      hs := 0;
  49.      rs := 0;
  50.      f.init(fn,32,fOPENSHARE);
  51.      f.fetchN(0,buf);
  52.      if f.NoError then
  53.           begin
  54.           if (buf[1] = $03) or (buf[1] = $83) then { dBase version #s }
  55.                begin
  56.                move(buf[9],hs,2);
  57.                move(buf[11],rs,2);
  58.               { OUT('rec size = ',rs+'   hdr size=',hs);}
  59.                end;
  60.           end;
  61.      f.done;
  62.      hsiz := hs;
  63.      rsiz := rs;
  64.      ThisIsDBFFile := (hs > 0);
  65.      end;
  66.  
  67.  
  68. Function OpenAsDBFFile(fn : string; var f : BFILE_object) : boolean;
  69. var rs,hs  : integer;
  70.      begin
  71.      rs := 0;
  72.      hs := 0;
  73.      if ThisIsDBFFile(fn,hs,rs) then
  74.           begin
  75.           f.initWithHdr(fn,rs,hs,fOPENSHARE);
  76.           end
  77.      else OUT('This is not a DBF file ['+fn+']');
  78.      OpenAsDBFFile := f.opened;
  79.      end;
  80.  
  81.  
  82. procedure SmartDump;
  83. var l : longint;
  84.     results : integer;
  85.     rbuf : array[1..4096] of byte;
  86.     zbuf : array[1..16] of byte;
  87.     i    : integer;
  88.     j,filsz,reccount    : longint;
  89.     skipit : boolean;
  90.      begin
  91.      l := 0;
  92.      if not X.opened then exit;
  93.      filsz := filesize(X.fil);
  94.      OUT(' ');
  95.      OUT('Dump: '+X.filename+
  96.              '  Size:'+longintstr(filsz,9));
  97.      OUT('              HdrSiz:'+integerstr(X.hdrsiz,4)+
  98.              '  RecSiz:'+integerstr(X.recsiz,4)+
  99.              '  Recs:'+longintstr(X.count,8));
  100.      if (X.hdrsiz > 0) and (X.hdrptr <> NIL) then
  101.           begin
  102.           X.ReadHeader;
  103.           if X.NoError then
  104.                begin
  105.                i := 1;
  106.                if hdrlineflag then OUT('Header - size='+ integerstr(X.hdrsiz,4));
  107.                while i < X.hdrsiz do
  108.                    begin
  109.                    move(X.hdrptr^[i],zbuf,16);
  110.                    OUT(Buf16ToHexStr(i,((X.hdrsiz-i)+1),zbuf,HexAddrFlag));
  111.                    i := i + 16;
  112.                    end;
  113.                if X.hdrsiz > 16 then OUT(' ');
  114.                end
  115.           else OUT('Read Header error '+integerstr(X.err,4));
  116.           end;
  117.      j := 0;
  118.      reccount := X.count;
  119.      if (reccount = 0) and (filsz > 0) then reccount := 1;
  120.      while j < reccount do
  121.           begin
  122.           skipit := false;
  123.           if (pFirst > 1) and (j < pFirst) then skipit := true
  124.           else if recsread > pLast then exit;
  125.  
  126.           fillchar(rbuf,sizeof(rbuf),0);
  127.           X.fetchN(j,rbuf);
  128.           if X.NoError then
  129.                begin
  130.                     inc(recsread);
  131.                if not skipit then
  132.                     begin
  133.                     i := 1;
  134.                     if reclineflag then
  135.                          OUT('Record - '+integerstr(j,5)+'    size='+
  136.                               integerstr(X.recsiz,4));
  137.                     while i < X.recsiz do
  138.                         begin
  139.                         move(rbuf[i],zbuf,16);
  140.                         if X.recsiz > 16 then
  141.                              OUT(Buf16ToHexStr(i,((X.recsiz-i)+1),zbuf,HexAddrFlag))
  142.                         else OUT(Buf16ToHexStr(X.RecAddress(j),16,zbuf,HexAddrFlag));
  143.                         i := i + 16;
  144.                         end;
  145.                     if X.recsiz > 16 then OUT(' ');
  146.                     end;
  147.                end
  148.           else begin
  149.                OUT('Fetch error '+integerstr(X.err,4));
  150.                end;
  151.           inc(j);
  152.           end;
  153.      end;
  154.  
  155.  
  156. Procedure DoDump;
  157. var RSiz, HSiz : integer;
  158.     filsz : longint;
  159.      begin
  160.      if RecSize > 16 then reclineflag := true;
  161.      if HdrSize > 0  then hdrlineflag := true;
  162.      if DBFFlag then
  163.           begin
  164.           if ThisIsDBFFile(pCurrFName,RSiz,HSiz) then
  165.                begin
  166.                OUT('Interpreting this file as an xBase DBF file');
  167.                reclineflag := true;
  168.                hdrlineflag := true;
  169.                OpenAsDBFFile(pCurrFName,X);
  170.                end
  171.           else begin
  172.                OUT('This file is NOT a valid xBASE DBF file. Header(?):');
  173.                pfirst := 1; pcount := 4;
  174.                X.InitWithHdr(pCurrFName, 16,0, fOPENSHARE);
  175.                end;
  176.           end
  177.      else if HdrSize > 0 then
  178.           begin
  179.           X.InitWithHdr(pCurrFName, RecSize, HdrSize, fOPENSHARE);
  180.           end
  181.      else begin
  182.           X.Init(pCurrFName, RecSize, fOPENSHARE);
  183.           filsz := filesize(X.fil);
  184.           if RecSize > filsz then RecSize := trunc(filsz);   { very short files}
  185.           X.done;
  186.           X.Init(pCurrFName, RecSize, fOPENSHARE);
  187.           end;
  188.      SmartDump;
  189.      X.done;
  190.      end;
  191.  
  192.  
  193. Procedure DUMPProgInit;
  194. var chunk : integer;
  195.      begin
  196.      recsread    := 0;
  197.      reclineflag := false;
  198.      hdrlineflag := false;
  199.  
  200.      AddParm(1,'COMPRESSED','YES');
  201.      AddParm(1,'HEX','YES');
  202.      AddParm(1,'DBF','NO');
  203.      AddParm(1,'RECSIZE','16');
  204.      AddParm(1,'HDRSIZE','0');
  205.      AddParm(1,'FIRST','0');
  206.  
  207.      StandardOUTInit;
  208.  
  209.      HexAddrFlag := CheckOK('HEX');
  210.      DBFFlag     := CheckOK('DBF');
  211.      RecSize     := GetParmNum('RECSIZE');
  212.      HdrSize     := GetParmNum('HDRSIZE');
  213.      if pDEBUG then
  214.           OUT('first,last,count '+ integerstr(pfirst,5) +'  '+
  215.                               integerstr(plast,5) +'  '+
  216.                               integerstr(pcount,5));
  217.      end;
  218.  
  219.  
  220.      begin {initialization}
  221.      pProgID := 'DUMP 2.05';
  222.      DUMPProgInit;
  223.      if paramcount > 0 then pCurrFName := UpCaseStr(paramstr(1));
  224.      if pCurrFName[1] <> '<' then
  225.           begin
  226.           if fileexists(pCurrFName) then DoDUMP
  227.           else writeln('Unable to find file: ',pCurrFName);
  228.           end
  229.      else begin
  230.           ShowDocFile;
  231.           end;
  232.      OUTdone;
  233.      end.
  234.